home *** CD-ROM | disk | FTP | other *** search
/ Amiga Plus 1997 #3 / Amiga Plus CD - 1997 - No. 03.iso / pd / programmierung / alienbreed3d2_src / amos / 256texture.amos / 256texture.amosSourceCode
AMOS Source Code  |  1997-01-31  |  4KB  |  172 lines
  1. Set Buffer 20
  2. Screen Open 7,640,24,2,Hires : Wait Vbl : Curs Off : Flash Off : Extension_12_0380 -1
  3. Palette $8,$FF0 : Paper 0 : Pen 1 : Ink 1 : Box 0,4 To 639,20 : Wait Vbl 
  4. Screen Display 7,,Y Hard(7,72),,
  5.  
  6. Reserve As Work 15,65536*2
  7. Trap Bload "ab3:includes/256pal",Start(15)
  8. If Errtrap
  9.    Screen To Front 7 : Screen 7
  10.    Locate 1,1 : Print Space$(78)
  11.    Locate 1,1 : Centre "Unable to load 'ab3:includes/256pal'"
  12.    Wait Key 
  13.    Edit 
  14. End If 
  15. Dim R(255),G(255),B(255),CO(63),GLARE(31)
  16. Dim PR(31),PG(31),PB(31)
  17. S=Start(15)
  18. For A=0 To 255
  19.    R(A)=Deek(S) : Add S,2
  20.    G(A)=Deek(S) : Add S,2
  21.    B(A)=Deek(S) : Add S,2
  22. Next 
  23. Reserve As Work 14,100000
  24. For A=1 To 32
  25.    
  26.    M$="ab3:graphics/textures/glare."+Str$(A)-" "
  27.    If Exist(M$)
  28.       GLARE(A-1)=1
  29.       Trap Load Iff M$,0
  30.       If Errtrap
  31.          Screen To Front 7 : Screen 7
  32.          Locate 1,1 : Print Space$(78)
  33.          Locate 1,1 : Centre "Unable to load '"+M$+"'"
  34.          Wait Key 
  35.          Edit 
  36.       End If 
  37.    Else 
  38.       GLARE(A-1)=0
  39.       M$="ab3:graphics/textures/texture."+Str$(A)-" "
  40.       Trap Load Iff M$,0
  41.       If Errtrap
  42.          Screen To Front 7 : Screen 7
  43.          Locate 1,1 : Print Space$(78)
  44.          Locate 1,1 : Centre "Unable to load '"+M$+"'"
  45.          Wait Key 
  46.          Edit 
  47.       End If 
  48.    End If 
  49.    Trap Bload M$,Start(14)
  50.    If Errtrap
  51.       Screen To Front 7 : Screen 7
  52.       Locate 1,1 : Print Space$(78)
  53.       Locate 1,1 : Centre "Unable to load '"+M$+"'"
  54.       Wait Key 
  55.       Edit 
  56.    End If 
  57.    
  58.    S=Hunt(Start(14) To Start(14)+10000,"CMAP")+8
  59.    For B=0 To 31
  60.       PR=Peek(S) : Add S,1
  61.       PG=Peek(S) : Add S,1
  62.       PB=Peek(S) : Add S,1
  63.       '         PR(B+32)=PR(B)/2 
  64.       '         PG(B+32)=PG(B)/2 
  65.       '         PB(B+32)=PB(B)/2 
  66.       PR(B)=PR
  67.       PG(B)=PG
  68.       PB(B)=PB
  69.    Next 
  70.    
  71.    If GLARE(A-1)=0
  72.       Screen To Front 7 : Screen 7
  73.       Locate 1,1 : Print Space$(78)
  74.       Locate 1,1 : Centre "Grabbing colours"
  75.       For B=0 To 31
  76.          
  77.          ND=100000000 : T=0
  78.          For Z=0 To 255
  79.             D=Abs(R(Z)-PR(B))+Abs(G(Z)-PG(B))+Abs(B(Z)-PB(B))
  80.             If D<ND
  81.                ND=D : T=Z
  82.             End If 
  83.             If D=0
  84.                Z=255
  85.             End If 
  86.          Next 
  87.          
  88.          CO(B)=T
  89.          
  90.       Next 
  91.    Else 
  92.       For B=0 To 31 : CO(B)=B : Next 
  93.    End If 
  94.    
  95.    B=A-1
  96.    S=Start(15)+(B mod 4)+((B/4) and 3)*256+(B/16)*65536
  97.    Screen To Front 7 : Screen 7
  98.    Locate 1,1 : Print Space$(78)
  99.    Locate 1,1 : Centre "Grabbing Texture "+(Str$(A)-" ")+"/32"
  100.    Screen 0
  101.    For X=0 To 63 : For Y=0 To 63
  102.          Poke S+X*4+Y*1024,CO( Extension_12_044C(X,Y))
  103.           Extension_12_036E X,Y,0
  104.    Next : Next 
  105.    
  106. Next 
  107.  
  108. F$=Fsel$("ab3:includes/","newtexturemaps","Select a save name for the datafile:")
  109.  
  110. Trap Bsave F$,Start(15) To Start(15)+(65536*2)
  111. If Errtrap
  112.    Screen To Front 7 : Screen 7
  113.    Locate 1,1 : Print Space$(78)
  114.    F$="Unable to save "+F$
  115.    Locate 1,1 : Centre F$
  116.    Wait Key 
  117.    Edit 
  118. End If 
  119.  
  120. 'N=Start(14) 
  121. 'For A=32 To 1 Step -1 
  122. '   For QB=0 To 255
  123. '
  124. '      R=(R(QB)*A)/32
  125. '      G=(G(QB)*A)/32
  126. '      B=(B(QB)*A)/32
  127. '      
  128. '      ND=100000000 : T=0
  129. '      For Z=0 To 255
  130. '         D=Abs(R(Z)-R)+Abs(G(Z)-G)+Abs(B(Z)-B)
  131. '         If D<ND
  132. '            ND=D : T=Z
  133. '         End If 
  134. '         If D=0 
  135. '            Z=255 
  136. '         End If 
  137. '      Next  
  138. '      
  139. '      Poke N,T : Add N,1
  140. '      
  141. '   Next 
  142. 'Next  
  143.  
  144.  
  145.  
  146. 'For A=32 To 1 Step -1 
  147. '   For QB=0 To 255
  148. '      
  149. '      If A>=16
  150. '         V=A-16 
  151. '         R=R(QB)+((255-R(QB))*V)/16 
  152. '         G=G(QB)+((255-G(QB))*V)/16 
  153. '         B=B(QB)+((255-B(QB))*V)/16 
  154. '      Else  
  155. '         R=(R(QB)*A)/16 
  156. '         G=(G(QB)*A)/16 
  157. '         B=(B(QB)*A)/16 
  158. '      End If  
  159. '      
  160. '      ND=100000000 : T=0
  161. '      For Z=0 To 255
  162. '         D=Abs(R(Z)-R)+Abs(G(Z)-G)+Abs(B(Z)-B)
  163. '         If D<ND Then ND=D : T=Z
  164. '         If D=0 Then Z=255
  165. '      Next  
  166. '      
  167. '      Poke N,T : Add N,1
  168. '      
  169. '   Next 
  170. 'Next  
  171.  
  172. 'Bsave "ab3:includes/newtexturemaps.pal",Start(14) To N